perm filename BITLAB[FOO,LMM]1 blob
sn#092637 filedate 1974-03-21 generic text, type T, neo UTF8
(FILECREATED "20-MAR-74 06:06:03" BITLABELER
changes to: SLTPS,LISTCYCLES,PERMTIMES,TAKEN,GCD,PERMCYCLEINDEX1,
BINARY.LSTG,LST.BINARYG,BINARY.LST,LST.BINARY,LISTELT,SIZE,FIRST,REST,MLG,ORBIT1
,REDUCEGROUP,COMB,MANYLABELGRAPHTOP,MANYLABELGRAPH,LABELCLASS,LABELGENCLASS,
LABELORBITS,LO1,ORBITS,CANONICAL,MAX,LABELGRAPH,GG2,GG1,GROUPGENBY,PR1,PRISM,
DIHEDRAL,REFLECTION,R1,SN,ID1,IDENTITY,DP2,DP1,DIRECTPRODUCT,CYC1,CYCLICGENBY,
PTIMES,XTIMES,XTIMES1,D2,D1,MAPCONS,IMAGES,MAPPINGS,CHECK,INSERTCL,DIFFCL,
SUBSETS,PCYCLEINDEX,CYCLEINDEX,LFROMCL,POLYA,IMAX,IMIN,BITLABELERVARS
previous date: "17-MAR-74 20:28:13")
(LISPXPRINT (QUOTE BITLABELERVARS)
T)
(RPAQQ BITLABELERVARS
((RECORDS PERMCYCLE PERMUTATION)
(PROP MACRO 2TO LOG2 CONTAINED ELTLESSP TWICE NEXTSMALLESTELT
DISJOINTDIFF ALLLARGERELTS LARGESTELT MAKESET DIFF1 ELEMENTOF
ADDELT DIFF EMPTY UNIONSET INTERSECT DISJOINT NULLSET EQSET
SIZE FIRST REST)
(FNS LISTCYCLES ELTTIMES PERMTIMES TAKEN GCD RELATIVELYPRIME LCM
PERMCYCLEINDEX1 BINARY.LSTG LST.BINARYG BINARY.LST LST.BINARY
LOG2 FOO CONTAINED LISTELT DM DIFF SIZE FIRST REST DWIMUSERFN
MAX LABELGRAPH GG2 GG1 GROUPGENBY PR1 PRISM DIHEDRAL REFLECTION
R1 SN ID1 IDENTITY DP2 DP1 DIRECTPRODUCT CYC1 CYCLICGENBY PTIMES
XTIMES XTIMES1 D2 D1 MAPCONS IMAGES MAPPINGS CHECK INSERTCL
DIFFCL SUBSETS PCYCLEINDEX CYCLEINDEX LFROMCL POLYA IMAX IMIN)
(FNS MLG ORBIT1 REDUCEGROUP COMB MANYLABELGRAPHTOP MANYLABELGRAPH
LABELCLASS LABELGENCLASS LABELORBITS LO1 LOADD ORBITS CANONICAL
SLTPS)))
(PROGN (QUOTE EVALUATE©)
(RECORD PERMCYCLE (SIZEOF . SETOF))
(RECORD PERMUTATION (CYCLESOF ORDEROF . POWERSOF)))
(DEFLIST(QUOTE(
[2TO ((N)
(LLSH 1 (SUB1 N]
(LOG2 NIL)
[CONTAINED ((A B)
(ZEROP (LOC (ASSEMBLE NIL (CQ (VAG A))
(PUSHN)
(CQ (VAG B))
(POP NP , 2)
(XOR 1 , 2)
(AND 1 , 2]
(ELTLESSP ((X Y)
(IGREATERP Y X)))
(TWICE ((X)
(LLSH X 1)))
(NEXTSMALLESTELT ((X)
(TWICE X)))
(DISJOINTDIFF ((X Y)
(LOGXOR X Y)))
(ALLLARGERELTS ((X)
(SUB1 X)))
(LARGESTELT (NIL 1))
(MAKESET (X (CONS (QUOTE LOGOR)
X)))
(DIFF1 ((A B)
(DIFF A B)))
(ELEMENTOF ((X A)
(CONTAINED X A)))
(ADDELT ((X A)
(UNION X A)))
[DIFF ((LAMBDA (A B)
(LOGAND A (LOGXOR B A]
(EMPTY ((X)
(ZEROP X)))
(UNIONSET ((A B)
(LOGOR A B)))
(INTERSECT ((A B)
(LOGAND A B)))
[DISJOINT ((A B)
(EMPTY (INTERSECT A B]
(NULLSET (NIL 0))
(EQSET ((X Y)
(EQP X Y)))
[SIZE ((A)
(LOC (ASSEMBLE NIL (CQ (VAG A))
(MOVE 2 , 1)
(HRRZI 1 , 0)
(JUMPE 2 , RET)
LP
(ADDI 1 , 1)
(MOVE 3 , 2)
(SUBI 3 , 1)
(AND 2 , 3)
(JUMPN 2 , LP)
RET]
[FIRST ((X)
(LOC (ASSEMBLE NIL (CQ (VAG X))
(HRREI 2 , -1)
(ADD 2 , 1)
(XOR 2 , 1)
(AND 1 , 2]
[REST ((X)
(LOC (ASSEMBLE NIL (CQ (VAG X))
(HRREI 2 , -1)
(ADD 2 , 1)
(AND 1 , 2]
))(QUOTE MACRO))
(DEFINEQ
(LISTCYCLES
[LAMBDA (PERM)
(* RETURNS THE LIST OF CYCLES OF PERM, WHERE CYCLE IS A LIST
OF ELEMENTS)
(PROG (LS X PX)
(SETQ X (CAR PERM))
(SETQ PX X)
L1 (SETQ LS (CONS [PROG ((RSLT))
LP (SETQ PX (ELTTIMES PX PERM))
(SETQ RSLT (CONS PX RSLT))
(COND
((EQ PX X)
(RETURN RSLT))
(T (GO LP]
LS))
[COND
((FOR OLD X IN PERM ALWAYS (THEREIS CYCLE IN LS
SUCHTHAT (MEMB X CYCLE)))
(RETURN (FOR X IN LS WHEN (CDR X) COLLECT X]
(SETQ PX X)
(GO L1])
(ELTTIMES
[LAMBDA (X P)
(CAR (FNTH P X])
(PERMTIMES
[LAMBDA (P1 P2)
(FOR X IN P1 COLLECT (ELTTIMES X P2])
(TAKEN
[LAMBDA (N I)
(BIND RESULT←1 FOR J FROM 1 TO I DO (SETQ RESULT (IQUOTIENT (ITIMES RESULT
N)
J))
(SETQ N (SUB1 N))
FINALLY (RETURN RESULT])
(GCD
[LAMBDA (N1 N2)
(COND
((EQ 0 (SETQ N1 (IREMAINDER N1 N2)))
N2)
(T (GCD N2 N1])
(RELATIVELYPRIME
[LAMBDA (N1 N2)
(EQ 1 (GCD N1 N2])
(LCM
[LAMBDA (N1 N2)
(IQUOTIENT (ITIMES N1 N2)
(GCD N1 N2])
(PERMCYCLEINDEX1
[LAMBDA (PERM)
(FOR CYCLE IN (fetch CYCLESOF of PERM) COLLECT (fetch SIZEOF of CYCLE])
(BINARY.LSTG
[LAMBDA (GROUP)
(FOR PERM IN GROUP COLLECT (FOR X IN (CAR (fetch POWERSOF of PERM))
COLLECT (LOG2 X])
(LST.BINARYG
[LAMBDA (GROUP)
(PROG (RESULTS CYCLES ORDERS P2 ORDER)
[FOR
PERM IN GROUP
DO
(COND
((SETQ CYCLES (LISTCYCLES PERM))
(SETQ ORDER 1)
[FOR CYCLE IN CYCLES DO (SETQ ORDER (LCM ORDER (LENGTH CYCLE]
(SETQ ORDERS (CONS 1 (FOR I FROM 2 TO (LLSH ORDER -1)
WHEN (RELATIVELYPRIME I ORDER)
COLLECT I)))
(SETQ P2 PERM)
(SETQ RESULTS
(CONS
[CREATE
PERMUTATION ORDEROF ←(COND
((EQ ORDER 2)
NIL)
(T ORDERS))
CYCLESOF ←[SORT (FOR CYCLE IN CYCLES
COLLECT (CREATE PERMCYCLE SIZEOF ←(
LENGTH CYCLE)
SETOF ←(LST.BINARY
CYCLE)))
(FUNCTION (LAMBDA (X Y)
(ILESSP (fetch SIZEOF of X)
(fetch SIZEOF of Y]
POWERSOF ←(CONS
(MAPCAR PERM (QUOTE LST.BINARY))
(FOR I FROM 2 TO (FOR I IN ORDERS MAXIMUM I)
JOIN (PROGN (SETQ P2 (PERMTIMES PERM P2))
(COND
((MEMB I ORDERS)
(LIST (MAPCAR P2 (QUOTE LST.BINARY]
RESULTS]
(RETURN RESULTS])
(BINARY.LST
[LAMBDA (L)
(COND
((NULL L)
NIL)
((NLISTP L)
(FOR X IN (LISTELT L) COLLECT (LOG2 X)))
(T (MAPCAR L (QUOTE BINARY.LST])
(LST.BINARY
[LAMBDA (L)
(COND
((NULL L)
NIL)
((NLISTP L)
(2TO L))
((NLISTP (CAR L))
(bind RSLT←0 for X in L do (SETQ RSLT (UNIONSET RSLT (LST.BINARY X)))
finally (RETURN RSLT)))
(T (MAPCAR L (QUOTE LST.BINARY])
(LOG2
[LAMBDA (X)
(PROG ((I 0))
LP [COND
((ZEROP X)
(RETURN I))
(T (SETQ X (LLSH X -1]
(SETQ I (ADD1 I))
(GO LP])
(FOO
[LAMBDA (X Y)
(CONTAINED X Y])
(CONTAINED
[LAMBDA (A B)
(ZEROP (LOGAND A (LOGXOR A B])
(LISTELT
[LAMBDA (NODES)
(PROG (FN RSLT)
LP [COND
((EMPTY NODES)
(RETURN (DREVERSE RSLT]
(SETQ RSLT (CONS (FIRST NODES)
RSLT))
(SETQ NODES (REST NODES))
(GO LP])
(DM
[NLAMBDA L
[COND
((LISTP (CAR L))
(ERROR (CAR L)
(QUOTE "NOT ATOM"]
[RPLACA (QUOTE CHANGEDPROPLST)
(CONS (CAR L)
(CAR (QUOTE CHANGEDPROPLST]
(AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA)
CHANGEDPROPLST)))
(/PUT (CAR L)
(QUOTE MACRO)
(CDR L))
(ADDSPELL (CAR L))
(CAR L])
(DIFF
[LAMBDA (A B)
(LOGAND A (LOGXOR B A])
(SIZE
[LAMBDA (X)
(ADD1 (WHILE [NOT (EMPTY (SETQ X (REST X] SUM 1])
(FIRST
[LAMBDA (X)
(LOGAND X (LOGXOR X (SUB1 X])
(REST
[LAMBDA (X)
(LOGAND X (SUB1 X])
(DWIMUSERFN
[LAMBDA NIL
(PRINT FAULTX T)
NIL])
(MAX
[LAMBDA (I J)
(COND
((IGREATERP I J)
I)
(T J])
(LABELGRAPH
[LAMBDA (NODES GROUP NUMBER)
(COND
((NULL GROUP)
(FOR X IN (COMB NODES NUMBER) COLLECT (CONS X NIL)))
[(IGREATERP (ITIMES 2 NUMBER)
(SIZE NODES))
(FOR X IN (LABELGRAPH NODES GROUP (IDIFFERENCE (SIZE NODES)
NUMBER))
RCOLLECT (CONS (DIFF NODES (CAR X))
(CDR X]
((ZEROP NUMBER)
(LIST (CONS (NULLSET)
GROUP)))
(T (PROG (FC RESULT)
[COND
((EQSET NODES (SETQ FC (ORBIT1 NODES GROUP)))
(RETURN (LABELCLASS NODES GROUP NUMBER]
(SETQ NODES (DIFF NODES FC))
(FOR X FROM (MAX 0 (IDIFFERENCE NUMBER (SIZE NODES)))
TO (MIN NUMBER (SIZE FC))
AS LBLGS IS [SORT (LABELCLASS FC GROUP X)
(FUNCTION (LAMBDA (X Y)
(IGREATERP (CDR X)
(CDR Y]
AS OLDGROUP IS (QUOTE UNDEFINED) AS NMX IS (IDIFFERENCE
NUMBER X)
DO (FOR OLD LBLGS ON LBLGS
AS LBLGS2 IS (COND
((EQUAL (CAR (CDR LBLGS))
OLDGROUP)
LBLGS2)
(T (LABELGRAPH NODES (SETQ OLDGROUP (CDAR LBLGS))
NMX)))
FOR LBLG2
IN LBLGS2 DO (SETQ RESULT
(CONS (CONS (UNIONSET (CAAR LBLGS)
(CAR LBLG2))
(CDR LBLG2))
RESULT])
(GG2
[LAMBDA (G1*2 G1 G2 G)
(COND
((MEMBER G1*2 G)
(GG1 G1 (CDR G2)
G))
(T (PROGN (RPLACD G2 (CONS G1*2 (CDR G2)))
(GG1 G1 (CDR G2)
G])
(GG1
[LAMBDA (G1 G2 G)
(COND
((NULL G1)
G)
((NULL G2)
(GG1 (CDR G1)
(CDR G1)
G))
(T (GG2 (PTIMES (CAR G1)
(CAR G2))
G1 G2 G])
(GROUPGENBY
[LAMBDA (G)
(GG1 G G G])
(PR1
[LAMBDA (N P)
(MAPCAR N (FUNCTION (LAMBDA (X)
(PTIMES X (PTIMES P (PTIMES X P])
(PRISM
[LAMBDA (A B N)
(DIRECTPRODUCT (LIST (R1 A B N)
(IDENTITY N))
(PR1 (DIHEDRAL A N)
(R1 A B N])
(DIHEDRAL
[LAMBDA (A N)
(DIRECTPRODUCT (LIST (REFLECTION A N)
(IDENTITY N))
(CYCLICGENBY (D2 A N])
(REFLECTION
[LAMBDA (A N)
(R1 A NIL N])
(R1
[LAMBDA (A B N)
(COND
((IGREATERP (LENGTH A)
(ADD1 (LENGTH B)))
(R1 (CDR A)
(CONS (CAR A)
B)
N))
((NULL B)
(IDENTITY N))
(T (PTIMES (CADR (SN (LIST (IMIN (CAR A)
(CAR B))
(IMAX (CAR A)
(CAR B)))
N))
(R1 (CDR A)
(CDR B)
N])
(SN
[LAMBDA (A N)
(MAPPINGS A A (IDENTITY N])
(ID1
[LAMBDA (I N)
(COND
((IGREATERP I N)
NIL)
(T (CONS I (ID1 (ADD1 I)
N])
(IDENTITY
[LAMBDA (N)
(ID1 1 N])
(DP2
[LAMBDA (PCG P G PRD)
(COND
((MEMBER PCG PRD)
(DP1 P (CDR G)
PRD))
(T (DP1 P (CDR G)
(CONS PCG PRD])
(DP1
[LAMBDA (P G PRD)
(COND
((NULL G)
PRD)
(T (DP2 (PTIMES P (CAR G))
P G PRD])
(DIRECTPRODUCT
[LAMBDA (G1 G2)
(COND
((NULL G1)
NIL)
(T (DP1 (CAR G1)
G2
(DIRECTPRODUCT (CDR G1)
G2])
(CYC1
[LAMBDA (P1 P2)
(COND
((EQUAL P1 P2)
(LIST P1))
(T (CONS P2 (CYC1 P1 (PTIMES P1 P2])
(CYCLICGENBY
[LAMBDA (P)
(CYC1 P (PTIMES P P])
(PTIMES
[LAMBDA (P1 P2)
(MAPCAR P1 (FUNCTION (LAMBDA (Z)
(XTIMES Z P2])
(XTIMES
[LAMBDA (X P)
(XTIMES1 X 1 P])
(XTIMES1
[LAMBDA (X I P)
(COND
((EQ X I)
(CAR P))
(T (XTIMES1 X (ADD1 I)
(CDR P])
(D2
[LAMBDA (A N)
(D1 1 N A A])
(D1
[LAMBDA (I N Y A)
(COND
((IGREATERP I N)
NIL)
((NULL Y)
(CONS I (D1 (ADD1 I)
N A A)))
((NOT (EQ I (CAR Y)))
(D1 I N (CDR Y)
A))
((CDR Y)
(CONS (CADR Y)
(D1 (ADD1 I)
N A A)))
(T (CONS (CAR A)
(D1 (ADD1 I)
N A A])
(MAPCONS
[LAMBDA (X L)
(MAPCAR L (FUNCTION (LAMBDA (Y)
(CONS X Y])
(IMAGES
[LAMBDA (A2A A2B A B)
(COND
((NULL A2A)
NIL)
(T (APPEND (MAPCONS (CAR A2A)
(MAPPINGS (CDR A)
(APPEND (CDR A2A)
A2B)
(CDR B)))
(IMAGES (CDR A2A)
(CONS (CAR A2A)
A2B)
A B])
(MAPPINGS
[LAMBDA (A A2 B)
(COND
((NULL A)
(LIST B))
((NULL B)
NIL)
[(NOT (MEMBER (CAR B)
A))
(MAPCONS (CAR B)
(MAPPINGS A A2 (CDR B]
(T (IMAGES A2 NIL A B])
(CHECK
[LAMBDA (FN LEXP)
(PROG (NF)
(SETQ NF (PACK (LIST FN @ *CHK)))
[COND
[(GET (CDR FN)@ SUBR)
(PROGN (PUT NF @(GET (CDR FN)@ SUBR)
SUBR)
(PROG1 NIL (REMPROP FN @ SUBR]
((GET (CDR FN)@ EXPR)
(PUT NF @(GET (CDR FN)@ EXPR)
EXPR))
(T (RETURN @(? FN NOT EXPR OR SUBR]
(DEFINE @((? FN (LAMBDA ?
(CADR LEXP)
(PROG (CNT RES)
(SETQ RES ? (CONS NF (CADR LEXP)))
(SETQ CNT ? (CADDR LEXP))
(COND
((EQUAL (LENGTH RES)
CNT)
(RETURN RES)))
(PRINT (QUOTE (ERROR IN:)))
(PRIN1 (QUOTE ? FN))
(PRINT ? (CONS @ LIST (CADR LEXP)))
(PRIN1 (QUOTE "PREDICTED NUMBER="))
(PRINT CNT)
(PRIN1 (QUOTE "ACTUAL NUMBER="))
(PRINT (LENGTH RES))
(PRIN1 (QUOTE "VALUE IS="))
(PRINT RES)
(EXITERR T)
(ERROR (QUOTE ? FN])
(INSERTCL
[LAMBDA (NUMBER ELEMENT OLDCL ORDERF)
(IF (OR (NULL OLDCL)
(ORDERF ELEMENT (CAAR OLDCL)))
THEN (CONS (CONS ELEMENT NUMBER)
OLDCL)
ELSEIF (NOT (ORDERF (CAAR OLDCL)
ELEMENT))
THEN (RPLACD (CAR OLDCL)
(IPLUS (CDAR OLDCL)
NUMBER))
OLDCL
ELSE [FOR CL ON OLDCL DO (IF (OR (NULL (CDR CL))
(ORDERF ELEMENT (CAADR CL)))
THEN [RETURN (RPLACD CL (CONS (CONS ELEMENT
NUMBER)
(CDR CL]
ELSEIF (NOT (ORDERF (CAADR CL)
ELEMENT))
THEN (RETURN (RPLACD (CADR CL)
(IPLUS (CDADR CL)
NUMBER]
OLDCL])
(DIFFCL
[LAMBDA (L1 L2)
(FOR X IN L1 AS N IS (IDIFFERENCE (CDR X)
(OR (CDR (SASSOC (CAR X)
L2))
0))
WHEN (IGREATERP N 0) COLLECT (CONS (CAR X)
N])
(SUBSETS
[LAMBDA (C N)
(COND
[(EQ 0 N)
(QUOTE ((NIL . 1]
((FOR OLD C ON C ALWAYS (IGREATERP (CAAR C)
N))
NIL)
(COMMENT GET RID OF NUMBERS AT HEAD THAT ARE TOO BIG)
(COMMENT RETURN NIL WHEN THEY ALL ARE TO BIG)
(T (FOR I FROM 1 TO (CDAR C) AS II FROM (CAAR C) TO N
BY (CAAR C)
(* THE FIRST ELEMENT OF THE NEW SUBSET IS THE FIRST OF THE
OLD ;TRY UP TO HOW MANY ON THE OLD ;I IS THE NUMBER OF TIMES
IT OCCURS AND II IS THE AMOUNT TAKEN ;IT IS UPPER-BOUNDED BY
N)
AS X IS (SUBSETS (CDR C)
(IDIFFERENCE N II))
(* TRY EVERY SUBSET OF THE REST
ADDING UP TO N-II)
WHEN X AS FACTOR IS (TAKEN (CDAR C)
I)
(* X MUST NOT BE NIL ;THE FACTOR IS THE NUMBER OF WAYS OF
TAKING I ELEMENTS OUT OF THE (CDAR C) ELEMENT AVAILABLE)
FOR
OLD X ON X RCOLLECT FIRST (SUBSETS (CDR C)
N)
(* THE FIRST OF THE LIST IS ALL SUBSETS WITHOUT USING THE
FIRST OF C)
(CONS (CONS (CONS (CAAR C)
I)
(CAAR X))
(ITIMES FACTOR (CDAR X])
(PCYCLEINDEX
[LAMBDA (CYCLES NODES)
(PROG (INDEX)
(FOR CYCLE IN CYCLES AS CYCLESIZE IS
(SIZE (INTERSECT (fetch SETOF of CYCLE)
NODES))
DO (SETQ INDEX (INSERTCL 1 CYCLESIZE INDEX @ LESSP)))
(RETURN (IF [NOT (EQP 0 (SETQ CYCLES
(IDIFFERENCE (SIZE NODES)
(FOR X
IN INDEX PLUS
(ITIMES (CAR X)
(CDR X]
THEN (CONS (CONS 1 CYCLES)
INDEX)
ELSE INDEX])
(CYCLEINDEX
[LAMBDA (GROUP NODES)
(PROG (INDEX)
[FOR PERM IN GROUP AS DUPLICITY IS
[IF (OR (NOT (fetch ORDEROF of PERM))
(EQ INPUTMODE @ FUNCTION))
THEN 1
ELSE (TWICE (LENGTH (fetch ORDEROF
of PERM]
DO (SETQ INDEX (INSERTCL DUPLICITY (PCYCLEINDEX (fetch CYCLESOF
of PERM)
NODES)
INDEX
(FUNCTION (LAMBDA (X Y)
(NOT (NOT (ILESSP X Y]
(RETURN (CONS (CONS (LIST (CONS 1 (SIZE NODES)))
1)
INDEX])
(LFROMCL
[LAMBDA (CL N)
(PROGN (SETQ CL (SORT (MAPCAR CL (QUOTE CDR))
(QUOTE LESSP)))
(IF [NOT (EQP 0 (SETQ N (IDIFFERENCE N
(SUM X FOR X IN CL]
THEN (INSERT N CL @ LESSP)
ELSE CL])
(POLYA
[LAMBDA (NODES GROUP SUBLIST)
(PROG (D C NEWGROUP)
(SETQ SUBLIST (LFROMCL SUBLIST (SIZE NODES)))
SETQ
NEWGROUP
(CYCLEINDEX GROUP NODES))
(SETQ C (FOR PERM IN NEWGROUP SUM (CDR PERM)))
1
(IF (NULL (CDR SUBLIST))
THEN (RETURN (IQUOTIENT (FOR X IN NEWGROUP SUM (CDR X))
C)))
(SETQ GROUP NEWGROUP)
(SETQ NEWGROUP NIL)
[FOR X IN GROUP FOR S IN (SUBSETS (CAR X)
(CAR SUBLIST))
AS CYCLEFT IS (DIFFCL (CAR X)
(CAR S))
AS FACTOR IS (ITIMES (CDR X)
(CDR S))
DO (SETQ NEWGROUP (INSERTCL FACTOR CYCLEFT NEWGROUP
(FUNCTION (LAMBDA (X Y)
(NOT (NOT (ILESSP X Y]
(SETQ SUBLIST (CDR SUBLIST))
(GO L1])
(IMAX
[LAMBDA (X Y)
(COND
((IGREATERP X Y)
X)
(T Y])
(IMIN
[LAMBDA (X Y)
(if X LT Y
then X
else Y])
)
(DEFINEQ
(MLG
[LAMBDA (NODES GROUP LABELS)
(FOR X IN (MANYLABELGRAPHTOP (LST.BINARY NODES)
(LST.BINARYG GROUP)
LABELS)
DO (FOR Y IN (CDR X) DO (PRIN1 (CAR Y))
(PRIN1 (BINARY.LST (CDR Y)))
(SPACES 2))
[COND
((LISTP (CAR (QUOTE PICTURE)))
(FOR I FROM 1 TO (FOR II IN PICTURE MAXIMUM (CADR II))
DO (TERPRI)
(FOR P IN PICTURE WHEN (EQ I (CADR P))
AS ELT IS (LST.BINARY (CAR P)) AS Y IS X
DO (PROG NIL
(COND
((NOT (NUMBERP (CAR P)))
(GO L2)))
(TAB (CDDR P))
L1 [COND
((NULL (SETQ Y (CDR Y)))
(PRIN1 @ ?))
((DISJOINT ELT (CDAR Y))
(GO L1))
(T (PRIN1 (CAAR Y]
(GO L3)
L2 (PRIN1 (CAR P))
L3]
(TERPRI)
(PRIN1 (QUOTE "REMAINING GROUP ="))
(TAB 20)
(PRINT (BINARY.LSTG (CAR X])
(ORBIT1
[LAMBDA (NODES GROUP)
(PROG (CLASS)
(SETQ CLASS (FIRST NODES))
(FOR OLD GROUP ON GROUP FOR PERM ON (fetch CYCLESOF
of (CAR GROUP))
AS CYCLE IS (fetch SETOF of (CAR PERM))
WHEN (NOT (DISJOINT CYCLE CLASS)) DO (SETQ CLASS (UNIONSET CYCLE
CLASS)))
(RETURN (INTERSECT CLASS NODES])
(REDUCEGROUP
[LAMBDA (GROUP NODES)
(FOR OLD GROUP ON GROUP WHEN (FOR PERM ON (fetch CYCLESOF
of (CAR GROUP))
AS CYCLE IS (fetch SETOF
of (CAR PERM))
AS X IS (INTERSECT NODES CYCLE)
ALWAYS (OR (EMPTY X)
(EQSET X CYCLE)))
COLLECT (CAR GROUP])
(COMB
[LAMBDA (NODES NUMBER)
(COND
((EQP 0 NUMBER)
(LIST (NULLSET)))
((EMPTY NODES)
NIL)
((EQ NUMBER 1)
(LISTELT NODES))
(T (FOR FN IS (FIRST NODES) AS OLD NODES IS (REST NODES) AS NN
FROM (SIZE NODES) TO NUMBER BY -1 FOR X IN (COMB NODES
(SUB1 NUMBER))
RCOLLECT (UNIONSET FN X])
(MANYLABELGRAPHTOP
[LAMBDA (NODES GROUP LABELS)
(PROG (X SZNODES)
(SETQ SZNODES (SIZE NODES))
[SORT LABELS (FUNCTION (LAMBDA (X Y)
(ILESSP (CDR X)
(CDR Y]
(SETQ X (POLYA NODES GROUP LABELS))
[PRINT (CONS X (QUOTE (POSSIBLE SUBSTITUTION (S]
[COND
((IGREATERP X 1000)
(RETURN (PROGN (PRINT (QUOTE (THIS IS TOO MANY TO COMPUTE)))
NIL]
(SETQ X (MANYLABELGRAPH NODES GROUP LABELS))
[PRINT (CONS (LENGTH X)
(QUOTE (ACTUAL SUBSTITUTIONS MADE]
(RETURN X])
(MANYLABELGRAPH
[LAMBDA (NODES GROUP LABELS)
(COND
((FOR OLD LABELS ON LABELS ALWAYS (EQP 0 (CDAR LABELS)))
NIL)
[(NULL (CDR LABELS))
(FOR X IN (LABELGRAPH NODES GROUP (CDAR LABELS))
RCOLLECT (LIST (CDR X)
(CONS (CAAR LABELS)
(CAR X]
(T (FOR NODGRP IN (LABELGRAPH NODES GROUP (CDAR LABELS)) FOR LABELING
IN (MANYLABELGRAPH (DIFF NODES (CAR NODGRP))
(CDR NODGRP)
(CDR LABELS))
RCOLLECT (CONS (CAR LABELING)
(CONS (CONS (CAAR LABELS)
(CAR NODGRP))
(CDR LABELING])
(LABELCLASS
[LAMBDA (CLASS GROUP NUMBER)
(COND
[(IGREATERP (TWICE NUMBER)
(SIZE CLASS))
(FOR X IN (LABELCLASS CLASS GROUP (IDIFFERENCE (SIZE CLASS)
NUMBER))
RCOLLECT (CONS (DIFF CLASS (CAR X))
(CDR X]
((EQP 0 NUMBER)
(LIST (CONS (NULLSET)
GROUP)))
[(EQ NUMBER 1)
(LIST (CONS (SETQ CLASS (FIRST CLASS))
(REDUCEGROUP GROUP CLASS]
(T (LABELGENCLASS CLASS GROUP NUMBER])
(LABELGENCLASS
[LAMBDA (CLASS GROUP NUMBER)
(FOR X IN (LABELORBITS (ORBITS CLASS GROUP)
NUMBER)
WHEN (CANONICAL X GROUP) RCOLLECT (CONS X (REDUCEGROUP GROUP X])
(LABELORBITS
[LAMBDA (ORBITS NUMBER)
(PROGN (SETQ LORESULT NIL)
(LO1 ORBITS NUMBER (NULLSET))
LORESULT])
(LO1
[LAMBDA (ORBITS NUMBER SET)
(COND
((MINUSP NUMBER)
NIL)
((EQP 0 NUMBER)
(LOADD SET))
((ILESSP (LENGTH ORBITS)
NUMBER)
NIL)
[(EQ (LENGTH ORBITS)
NUMBER)
(LOADD (PROG ((RESULT SET))
[FOR X IN ORBITS DO (SETQ RSLTS (UNIONSET RSLTS
(FIRST X]
(RETURN RSLTS]
(T (LO1 (CDR ORBITS)
NUMBER SET)
(LO1 (FOR O IN (CDR ORBITS) WHEN (DISJOINT (FIRST O)
(CAR ORBITS))
COLLECT O)
(IDIFFERENCE NUMBER (SIZE (CAR ORBITS)))
(UNIONSET SET (CAR ORBITS])
(LOADD
[LAMBDA (NODES)
(SETQ LORESULT (CONS NODES LORESULT])
(ORBITS
[LAMBDA (NODES GROUP)
(COND
((EMPTY NODES)
NIL)
((NULL GROUP)
(LISTELT NODES))
(T (CONS (ORBIT1 NODES GROUP)
(ORBITS (REST NODES)
(REDUCEGROUP GROUP (FIRST NODES])
(CANONICAL
[LAMBDA (NODES GROUP)
(FOR PERM IN GROUP ALWAYS (COND
[(NULL (fetch ORDEROF of PERM))
(SLTPS (LARGESTELT)
NODES
(CAR (fetch POWERSOF of PERM]
(T (FOR P IN (fetch POWERSOF of PERM)
AS PRED IS (SLTPSANDPINVS NODES P)
WHILE (NEQ PRED (QUOTE EQL))
ALWAYS PRED])
(SLTPS
[LAMBDA (I S P)
(PROG NIL
L1 [COND
[(NOT (CONTAINED I S))
(COND
((CONTAINED (CAR P)
S)
(RETURN T))
(T (SETQ P (CDR P))
(SETQ I (NEXTSMALLESTELT I]
((NOT (CONTAINED (CAR P)
S))
(RETURN NIL))
((ELTLESSP (SETQ I (NEXTSMALLESTELT I))
S)
(RETURN (QUOTE EQL)))
(T (SETQ P (CDR P]
(GO L1])
)
STOP